home *** CD-ROM | disk | FTP | other *** search
/ Cream of the Crop 26 / Cream of the Crop 26.iso / program / fpkpas92.zip / SRCRTL.ZIP / RTL / DOS / TEXT.PPI < prev    next >
Text File  |  1997-07-02  |  15KB  |  445 lines
  1. {***************************************************************************}
  2. {                               Text Output                                 }
  3. {***************************************************************************}
  4.  
  5.     const
  6.        { Support 16 Vector Fonts             }
  7.        { To load more fonts, increase this   }
  8.        maxfonts = 16;
  9.        fontdivs:array[0..maxfonts]of integer=
  10.        (1,4,3,4,4,4,4,4,4,3,3,1,1,1,1,1,1);
  11.     
  12.     type
  13.        pbyte = ^byte;
  14.  
  15.     {$PACKRECORDS 1}
  16.        pfontdata = ^tfontdata;
  17.  
  18.        tfontdata = record
  19.           filetyp              : char;
  20.           nr_chars             : word;
  21.           undefined1           : byte;
  22.           value_first_char     : byte;
  23.           undefined2           : array[1..3] of byte;
  24.           dist_origin_top      : shortint;
  25.           dist_origin_baseline : shortint;
  26.           dist_origin_bottom   : shortint;
  27.           undefined3           : array[1..5] of byte;
  28.        end;
  29.  
  30.     {$PACKRECORDS NORMAL}
  31.  
  32.        tfontrec = record
  33.           name : string[8];
  34.           data : pointer;
  35.           header : pfontdata;
  36.           offsets : pword;
  37.           widths : pbyte;
  38.           instr : pbyte;
  39.        end;
  40.  
  41.     var
  42.        fonts : array[1..maxfonts] of tfontrec;
  43.        installedfonts : longint;
  44.  
  45. {$I FONT.PPI}
  46.  
  47.     { returns true if p points to valid font file }
  48.  
  49.     function testfont(p : pointer) : boolean;
  50.  
  51.       begin
  52.          testfont:=(pchar(p)^='P') and
  53.           (pchar(p+1)^='K') and
  54.           (pchar(p+2)^=#8) and
  55.           (pchar(p+3)^=#8);
  56.       end;
  57.  
  58.     { set help data for font with number font            }
  59.     { pointer data must already be set                   }
  60.  
  61.     function setupfont(font : word) : integer;
  62.  
  63.       begin
  64.          setupfont:=grOK;
  65.          fonts[font].header:=fonts[font].data+$80;
  66.          if fonts[font].header^.filetyp<>'+' then
  67.            begin
  68.               setupfont:=grInvalidFont;
  69.               exit;
  70.            end;
  71.          fonts[font].offsets:=fonts[font].data+$90;
  72.          fonts[font].widths:=pbyte(fonts[font].offsets+fonts[font].header^.nr_chars*2);
  73.          fonts[font].instr:=fonts[font].widths+fonts[font].header^.nr_chars;
  74.       end;
  75.  
  76.     function InstallUserFont(const FontFileName : string) : integer;
  77.  
  78.       begin
  79.          _graphresult:=grOk;
  80.          { grapf mode must be set! }
  81.          { is enough place for a font ? }
  82.          if installedfonts=maxfonts then
  83.            begin
  84.               _graphresult:=grError;
  85.               exit;
  86.            end;
  87.          inc(installedfonts);
  88.          fonts[installedfonts].name:=FontFileName;
  89.          fonts[installedfonts].data:=nil;
  90.          InstallUserFont:=installedfonts;
  91.       end;
  92.  
  93.     function RegisterBGIfont(font : pointer) : integer;
  94.  
  95.       var
  96.          hp : pbyte;
  97.          b : word;
  98.          name : string[12];
  99.  
  100.       begin
  101.          { not yet guaranteed thad everything works }
  102.          RegisterBGIfont:=grInvalidFontNum;
  103.          { graphmode must not be set ! }
  104.          if testfont(font) then
  105.            begin
  106.               hp:=pbyte(font);
  107.               { search end of text header }
  108.               while hp^<>$1a do
  109.                 hp:=hp+1;
  110.               { jump to start of name }
  111.               hp:=hp+3;
  112.               { Namen lesen }
  113.               name:='';
  114.               for b:=0 to 3 do
  115.                 name:=name+char((hp+b)^);
  116.               { search correct font  }
  117.               for b:=1 to installedfonts do
  118.                 begin
  119.                    if fonts[b].name=name then
  120.                      begin
  121.                         fonts[b].data:=font;
  122.                         RegisterBGIfont:=grOK;
  123.                         RegisterBGIfont:=setupfont(b);
  124.                      end;
  125.                 end;
  126.            end
  127.          else
  128.            RegisterBGIFont:=grInvalidFont;
  129.       end;
  130.  
  131.     procedure GetTextSettings(var TextInfo : TextSettingsType);
  132.  
  133.       begin
  134.          _graphresult:=grOk;
  135.          if not isgraphmode then
  136.            begin
  137.               _graphresult:=grnoinitgraph;
  138.               exit;
  139.            end;
  140.          textinfo:=akttextinfo;
  141.       end;
  142.  
  143.     procedure OutText(const TextString : string);
  144.       var x,y:integer;
  145.       begin
  146.          _graphresult:=grOk;
  147.          if not isgraphmode then
  148.            begin
  149.               _graphresult:=grnoinitgraph;
  150.               exit;
  151.            end;
  152.          x:=curx; y:=cury;
  153.          OutTextXY(curx,cury,TextString);
  154.          { if output is done horizontal and left justified }
  155.          { update graph cursor }
  156.          if (akttextinfo.direction=HorizDir) and
  157.            (akttextinfo.horiz=LeftText) then
  158.                inc(x,textwidth(TextString));
  159.          curx:=x; cury:=y;   { LineTo changes GrafikCursor !! }
  160.       end;
  161.  
  162.     procedure outtext(const charakter : char);
  163.     var s:string;
  164.         x,y:integer;
  165.     begin
  166.       s:=charakter;
  167.       _graphresult:=grOk;
  168.          if not isgraphmode then
  169.            begin
  170.               _graphresult:=grnoinitgraph;
  171.               exit;
  172.            end;
  173.          x:=curx; y:=cury;
  174.          OutTextXY(curx,cury,s);
  175.          { wenn horizontal und linksb ndig ausgegeben wird, dann }
  176.          { Grafikcursor nachf hren }
  177.          { if (akttextinfo.direction=HorizDir) and
  178.            (akttextinfo.horiz=LeftText) then }
  179.                inc(x,textwidth(s));
  180.          curx:=x; cury:=y;   { LineTo manipuliert den GrafikCursor !! }
  181.     end;
  182.  
  183.     procedure OutTextXY(x,y : integer;const TextString : string);
  184.  
  185.       var
  186.          b1,b2         : shortint;
  187.          c,instr,mask  : byte;
  188.          i,j,k         : longint;
  189.          oldvalues     : linesettingstype;
  190.          nextpos       : word;
  191.          xpos,ypos,offs: longint;
  192.          FontPtr       : Pointer;
  193.       begin
  194.          _graphresult:=grOk;
  195.          if not isgraphmode then
  196.            begin
  197.               _graphresult:=grnoinitgraph;
  198.               exit;
  199.            end;
  200.  
  201.          { compute real x- and y- start position }
  202.          if akttextinfo.direction=horizdir then
  203.          begin
  204.            case akttextinfo.horiz of
  205.                 centertext : XPos:=(textwidth(textstring) shr 1);
  206.                 lefttext   : XPos:=0;
  207.                 righttext  : XPos:=textwidth(textstring);
  208.            end;
  209.            case akttextinfo.vert of
  210.                centertext : YPos:=(textheight(textstring) shr 1);
  211.                bottomtext : YPos:=0;
  212.                toptext    : YPos:=textheight(textstring);
  213.            end;
  214.          end else
  215.          begin
  216.            case akttextinfo.horiz of
  217.                 centertext : XPos:=(textheight(textstring) shr 1);
  218.                 lefttext   : XPos:=0;
  219.                 righttext  : XPos:=textheight(textstring);
  220.            end;
  221.            case akttextinfo.vert of
  222.                centertext : YPos:=(textwidth(textstring) shr 1);
  223.                bottomtext : YPos:=0;
  224.                toptext    : YPos:=textwidth(textstring);
  225.            end;     
  226.          end;         
  227.          X:=X-XPos; Y:=Y+YPos;
  228.          XPos:=X; YPos:=Y;
  229.          
  230.          if akttextinfo.font=DefaultFont then begin
  231.            y:=y-6;     
  232.            c:=textwidth(textstring) div 8 - 1; { Char counter }
  233.            FontPtr:=@defaultfontdata;
  234.            for i:=0 to c do begin
  235.              offs:=ord(textString[i+1]) shl 3;   { Offset of Chars in Data }
  236.              for j:=0 to 7 do begin
  237.                mask:=$80;
  238.                b1:=defaultfontdata[offs+j];    { Offset of Char line }
  239.                xpos:=i shl 3+x;
  240.                for k:=0 to 7 do begin
  241.                  if (b1 and mask) <> 0 then putpixel(xpos+k,j+y,aktcolor);
  242.                  mask:=mask shr 1;
  243.                end;
  244.              end;
  245.            end;
  246.          end else
  247.  
  248.            begin
  249.               { Linienstil setzen }
  250.               getlinesettings(oldvalues);
  251.               setlinestyle(solidln,oldvalues.pattern,normwidth);
  252.               if akttextinfo.direction=vertdir then xpos:=xpos + Textheight(textstring);
  253.               curx:=xpos; cury:=ypos; x:=xpos; y:=ypos;
  254.               for i:=1 to length(textstring) do
  255.                 begin
  256.                    c:=byte(textstring[i]);
  257.                    c:=c-fonts[akttextinfo.font].header^.value_first_char;
  258.                    { definiertes Zeichen ? }
  259.                    if (c<0) or (c>=fonts[akttextinfo.font].header^.nr_chars) then continue;
  260.                    nextpos:=fonts[akttextinfo.font].offsets[c];
  261.                    while true do
  262.                      begin
  263.                          b1:=fonts[akttextinfo.font].instr[nextpos];
  264.                          nextpos:=nextpos+1;
  265.                          b2:=fonts[akttextinfo.font].instr[nextpos];
  266.                          nextpos:=nextpos+1;
  267.                          instr:=((b1 and $80) shr 6)+((b2 and $80) shr 7);
  268.                          b1:=b1 and $7f;
  269.                          b2:=b2 and $7f;
  270.                          { Vorzeichen erweitern }
  271.                          if (b1 and $40)<>0 then b1:=b1 or $80;
  272.                          if (b2 and $40)<>0 then b2:=b2 or $80;
  273.                          { neue Stiftposition berechnen und skalieren }
  274.                          if akttextinfo.direction=VertDir then
  275.                            begin
  276.                              xpos:=x-((b2*aktmultx) div aktdivx);
  277.                              ypos:=y-((b1*aktmulty) div aktdivy);
  278.                            end
  279.                          else
  280.                            begin
  281.                              xpos:=x+((b1*aktmultx) div aktdivx) ;
  282.                              ypos:=y-((b2*aktmulty) div aktdivy) ;
  283.                            end;
  284.                          case instr of
  285.                             0 : break;
  286.                             2 : begin curx:=xpos; cury:=ypos; end;
  287.                             3 : begin line(curx,cury,xpos,ypos);
  288.                                       curx:=xpos; cury:=ypos;
  289.                                 end;
  290.                          end;
  291.                      end;
  292.                    if akttextinfo.direction=VertDir then
  293.                      y:=y-(fonts[akttextinfo.font].widths[c]*aktmultx div aktdivx)
  294.                    else
  295.                      x:=x+(fonts[akttextinfo.font].widths[c]*aktmultx div aktdivx) ;
  296.                 end;
  297.               setlinestyle( oldvalues.linestyle, oldvalues.pattern, oldvalues.thickness);
  298.            end;
  299.       end;
  300.  
  301.     procedure outtextxy(x,y: Integer;const charakter : char);
  302.     var s:string;
  303.     begin
  304.       s:=charakter;
  305.       outtextXY(x,y,s);
  306.     end;
  307.  
  308.     function TextHeight(const TextString : string) : word;
  309.  
  310.       begin
  311.          _graphresult:=grOk;
  312.          if not isgraphmode then
  313.            begin
  314.               _graphresult:=grnoinitgraph;
  315.               exit;
  316.            end;
  317.          if akttextinfo.font=DefaultFont
  318.             then TextHeight:=6+akttextinfo.charsize
  319.             else
  320.               TextHeight:=(((fonts[akttextinfo.font].header^.dist_origin_top-
  321.                 fonts[akttextinfo.font].header^.dist_origin_bottom) * aktmulty) div aktdivy) ;
  322.       end;
  323.  
  324.     function TextWidth(const TextString : string) : word;
  325.       var i,x : Integer;
  326.           c   : byte;
  327.       begin
  328.          _graphresult:=grOk;  x:=0;
  329.          if not isgraphmode then
  330.            begin
  331.               _graphresult:=grnoinitgraph;
  332.               exit;
  333.            end;
  334.          if akttextinfo.font = Defaultfont then
  335.             TextWidth:=length(TextString)*8*akttextinfo.charsize
  336.             else begin
  337.                for i:=1 to length(TextString) do begin
  338.                    c:=byte(textstring[i]);
  339.                    dec(c,fonts[akttextinfo.font].header^.value_first_char);
  340.                    { defined character ? }
  341.                    if (c<0) or (c>=fonts[akttextinfo.font].header^.nr_chars) then
  342.                      continue;
  343.                    x:=x+fonts[akttextinfo.font].widths[c];                  
  344.                end;
  345.             TextWidth:=((x * aktmultx) div aktdivx) ;
  346.             end;
  347.       end;
  348.  
  349.     procedure SetTextJustify(horiz,vert : word);
  350.  
  351.       begin
  352.          _graphresult:=grOk;
  353.          if not isgraphmode then
  354.            begin
  355.               _graphresult:=grnoinitgraph;
  356.               exit;
  357.            end;
  358.          if (horiz<0) or (horiz>2) or
  359.             (vert<0) or (vert>2) then
  360.            begin
  361.               _graphresult:=grError;
  362.               exit;
  363.            end;
  364.          akttextinfo.horiz:=horiz;
  365.          akttextinfo.vert:=vert;
  366.       end;
  367.  
  368.     procedure SetTextStyle(font,direction : word;charsize : word);
  369.  
  370.       var
  371.          f : file;
  372.  
  373.       begin
  374.          _graphresult:=grOk;
  375.          if not isgraphmode then
  376.            begin
  377.               _graphresult:=grnoinitgraph;
  378.               exit;
  379.            end;
  380.          { test validity of parameter }
  381.          if font>installedfonts then
  382.            begin
  383.               _graphresult:=grInvalidFontNum;
  384.               exit;
  385.            end;
  386.          akttextinfo.font:=font;
  387.          if (direction<>HorizDir) and (direction<>VertDir) then
  388.            direction:=HorizDir;
  389.          akttextinfo.direction:=direction;
  390.          akttextinfo.charsize:=charsize;
  391.          if (charsize <> usercharsize) then begin
  392.             aktmultx:=charsize;
  393.             aktdivx:=fontdivs[font];
  394.             aktmulty:=charsize;
  395.             aktdivy:=fontdivs[font];
  396.          end;
  397.          { load font file ? }
  398.          if (font>0) and not assigned(fonts[font].data) then
  399.            begin
  400.               assign(f,bgipath+fonts[font].name+'.CHR');
  401.               reset(f,1);
  402.               if ioresult<>0 then
  403.                 begin
  404.                    _graphresult:=grFontNotFound;
  405.                    akttextinfo.font:=DefaultFont;
  406.                    exit;
  407.                 end;
  408.               getmem(fonts[font].data,filesize(f));
  409.               if not assigned(fonts[font].data) then
  410.                 begin
  411.                    _graphresult:=grNoFontMem;
  412.                    akttextinfo.font:=DefaultFont;
  413.                    exit;
  414.                 end;
  415.               blockread(f,fonts[font].data^,filesize(f));
  416.  
  417.               if testfont(fonts[font].data) then
  418.                 _graphresult:=setupfont(font)
  419.               else
  420.                 begin
  421.                    _graphresult:=grInvalidFont;
  422.                    akttextinfo.font:=DefaultFont;
  423.                    freemem(fonts[font].data,filesize(f));
  424.                 end;
  425.               close(f);
  426.            end;
  427.       end;
  428.  
  429.     procedure SetUserCharSize(Multx,Divx,Multy,Divy : word);
  430.  
  431.       begin
  432.          _graphresult:=grOk;
  433.          if not isgraphmode then
  434.            begin
  435.               _graphresult:=grnoinitgraph;
  436.               exit;
  437.            end;
  438.          aktmultx:=Multx;
  439.          aktdivx:=Divx;
  440.          aktmulty:=Multy;
  441.          aktdivy:=Divy;
  442.       end;
  443.  
  444.  
  445.